home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / thomas / thomas.lha / Thomas / Thomas-1.1 / src / runtime-collections-table.scm < prev    next >
Text File  |  1992-08-30  |  7KB  |  198 lines
  1. ;*              Copyright 1992 Digital Equipment Corporation
  2. ;*                         All Rights Reserved
  3. ;*
  4. ;* Permission to use, copy, and modify this software and its documentation is
  5. ;* hereby granted only under the following terms and conditions.  Both the
  6. ;* above copyright notice and this permission notice must appear in all copies
  7. ;* of the software, derivative works or modified versions, and any portions
  8. ;* thereof, and both notices must appear in supporting documentation.
  9. ;*
  10. ;* Users of this software agree to the terms and conditions set forth herein,
  11. ;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free
  12. ;* right and license under any changes, enhancements or extensions made to the
  13. ;* core functions of the software, including but not limited to those affording
  14. ;* compatibility with other hardware or software environments, but excluding
  15. ;* applications which incorporate this software.  Users further agree to use
  16. ;* their best efforts to return to Digital any such changes, enhancements or
  17. ;* extensions that they make and inform Digital of noteworthy uses of this
  18. ;* software.  Correspondence should be provided to Digital at:
  19. ;* 
  20. ;*            Director, Cambridge Research Lab
  21. ;*            Digital Equipment Corp
  22. ;*            One Kendall Square, Bldg 700
  23. ;*            Cambridge MA 02139
  24. ;* 
  25. ;* This software may be distributed (but not offered for sale or transferred
  26. ;* for compensation) to third parties, provided such third parties agree to
  27. ;* abide by the terms and conditions of this notice.
  28. ;* 
  29. ;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL
  30. ;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF
  31. ;* MERCHANTABILITY AND FITNESS.   IN NO EVENT SHALL DIGITAL EQUIPMENT
  32. ;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
  33. ;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
  34. ;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS
  35. ;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
  36. ;* SOFTWARE.
  37.  
  38. ; $Id: runtime-collections-table.scm,v 1.16 1992/08/31 05:30:12 birkholz Exp $
  39.  
  40. ;;;; Specializations for tables.
  41.  
  42. (add-method dylan:shallow-copy
  43.   (dylan::function->method
  44.     (make-param-list `((TABLE ,<table>)) #F #F #F)
  45.     (lambda (table)
  46.       (let* ((new-table (dylan-call dylan:make <table>))
  47.          (key-sequence (dylan-call dylan:key-sequence table)))
  48.     (do ((state (dylan-call dylan:initial-state key-sequence)
  49.             (dylan-call dylan:next-state key-sequence state)))
  50.         ((not state)
  51.          (dylan-call dylan:as
  52.              (dylan-call dylan:class-for-copy table)
  53.              new-table))
  54.       (let ((key (dylan-call dylan:current-element key-sequence state)))
  55.         (dylan-call dylan:setter/element/
  56.             new-table
  57.             key
  58.             (dylan-call dylan:element table key))))))))
  59. (add-method dylan:as
  60.   (dylan::function->method
  61.    (make-param-list `((CLASS ,(dylan::make-singleton <table>))
  62.               (COLLECTION ,<collection>)) #F #F #F)
  63.    (lambda (class collection)
  64.      class
  65.      (if (dylan-call dylan:instance? collection <table>)
  66.      collection
  67.      (let ((table (dylan-call dylan:make <table>))
  68.            (key-sequence (dylan-call dylan:key-sequence collection)))
  69.        (do ((state (dylan-call dylan:initial-state key-sequence)
  70.                (dylan-call dylan:next-state key-sequence state)))
  71.            ((not state) table)
  72.          (let ((cur-element
  73.             (dylan-call dylan:current-element key-sequence state)))
  74.            (dylan-call dylan:setter/element/ table cur-element
  75.                (dylan-call
  76.                 dylan:element collection cur-element)))))))))
  77.  
  78.  
  79.  
  80. ;;;
  81. ;;; TABLE SPECIALIZED MAKE
  82. ;;; <table> creates an empty hash table
  83. ;;;
  84. (define *HASH-TABLE-SIZE* 500)
  85.  
  86. (define dylan:get-hash-table "define dylan:get-hash-table")
  87. (define dylan:set-hash-table! "define dylan:set-hash-table!")
  88. (create-private-slot <table> <vector> "internal-hash-table"
  89.   (lambda (set get)
  90.     (set! dylan:set-hash-table! set)
  91.     (set! dylan:get-hash-table get)))
  92. (add-method dylan:make
  93.   (dylan::function->method
  94.    (make-param-list `((TABLE ,(dylan::make-singleton <table>))) #F #F #T)
  95.    (lambda (class . rest)
  96.      class                ; ignored
  97.      rest                ; ignored
  98.      (let ((instance (dylan::make-<object> <table>)))
  99.        (dylan-call dylan:set-hash-table! instance
  100.           (make-vector *hash-table-size* '()))
  101.        instance))))
  102.  
  103. ;;;;
  104. ;;;; Operations on Tables (page 120)
  105. ;;;;
  106. (define (dylan-assoc key alist)        ; Use dylan:binary= to compare keys
  107.   (let loop ((rest-alist alist))
  108.     (if rest-alist
  109.     (if (dylan-call dylan:binary= key (caar rest-alist))
  110.         (car rest-alist)
  111.         (loop (cdr rest-alist)))
  112.     #F)))
  113.  
  114. (define dylan:remove-key!
  115.   (dylan::generic-fn 'remove-key!
  116.     (make-param-list `((TABLE ,<table>) (KEY ,<object>)) #F #F #F)
  117.     (lambda (table key)
  118.       (let* ((hash-table (dylan-call dylan:get-hash-table table))
  119.          (hash-index (dylan-call dylan:=hash key))
  120.          (hash-entry (vector-ref hash-table hash-index))
  121.          (match (dylan-assoc key hash-entry)))
  122.     (if match
  123.         (vector-set! hash-table hash-index
  124.              (dylan-call dylan:remove hash-entry match))
  125.         'no-match)))))
  126.  
  127.  
  128. (add-method dylan:setter/element/
  129.   (dylan::function->method
  130.     (make-param-list
  131.      `((TABLE ,<table>) (KEY ,<object>) (NEW-VALUE ,<object>)) #F #F #F)
  132.     (lambda (table key new-value)
  133.       (let ((hash-index (remainder (dylan-call dylan:=hash key)
  134.                    *HASH-TABLE-SIZE*))
  135.         (hash-table (dylan-call dylan:get-hash-table table)))
  136.     (if (>= hash-index (vector-length hash-table))
  137.         (dylan-call dylan:error "((setter element) <table> <object> <object>) -- internal error, size out of sync" table hash-index key new-value)
  138.         (let* ((hash-entry (vector-ref hash-table hash-index))
  139.            (match (dylan-assoc key hash-entry)))
  140.           (if match
  141.           (set-cdr! match (list new-value))
  142.           (vector-set! hash-table hash-index
  143.                    (cons (list key new-value)
  144.                      hash-entry)))
  145.           new-value))))))
  146.  
  147.  
  148.  
  149. (define (grow-vector-by v increase)
  150.   (let* ((n-old-values (vector-length v))
  151.      (new-v (make-vector (+ n-old-values increase))))
  152.     (vector-iterate v
  153.       (lambda (i entry) (vector-set! new-v i entry)))
  154.       new-v))
  155.  
  156.  
  157. (add-method dylan:map-into
  158.   (dylan::function->method
  159.     (make-param-list
  160.      `((TABLE ,<table>) (PROCEDURE ,<function>) (COLLECTION ,<collection>))
  161.      #F 'REST #F)
  162.     (lambda (table proc coll-1 . rest)
  163.       (let loop ((key-sequence (dylan-call dylan:key-sequence coll-1))
  164.          (rest-coll rest))
  165.     (if rest-coll
  166.         (loop (dylan-call dylan:intersection key-sequence
  167.                   (dylan-call dylan:key-sequence (car rest-coll)))
  168.              (cdr rest-coll))
  169.         (let ((all-collections (cons coll-1 rest)))
  170.           (do ((state (dylan-call dylan:initial-state key-sequence)
  171.               (dylan-call dylan:next-state key-sequence state)))
  172.           ((not state) table)
  173.         (let ((current-key (dylan-call
  174.                     dylan:current-element key-sequence state)))
  175.           (dylan-call
  176.            dylan:setter/element/
  177.            table
  178.            current-key
  179.            (dylan-call dylan:apply proc
  180.                    (map (lambda (coll)
  181.                       (dylan-call
  182.                        dylan:element coll current-key))
  183.                     all-collections)))))))))))
  184.  
  185. ;;;
  186. ;;; Mutable Collections
  187. ;;;
  188.  
  189. (add-method dylan:setter/current-element/
  190.   (dylan::function->method
  191.     (make-param-list
  192.      `((TABLE ,<table>) (STATE ,<object>) (new-value ,<object>)) #F #F #F)
  193.     (lambda (table state new-value)
  194.       (dylan-call dylan:setter/element/
  195.           table
  196.           (dylan-call dylan:current-key table state)
  197.           new-value))))
  198.